C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C    - REMOVE TABS
C    - PROGRAM UNITS RE-ORDERED
C    - ADDITIONAL YADEFS INCLUSIONS REMOVED
C    - DEFINES MOVED
C    - UNSPLIT LINES REMOVED
C    - CHANGE ZPTYPE TO ZPTYPE
C    - USE NEW TOKEN WRITE ROUTINE, CHANGE IODTKO/IODCMO FOR
C      TKNCHN AND USE ZTKPTI AS AN INITIALISATION CALL.
C
C--------   ISTUD.MAC
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
C
      PROGRAM ISTUD
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      COMMON/UNR/ DEPTH
      INTEGER DEPTH(3)
 
      INTEGER TKNPTH(81),CIPTH(81),NERROR,NWARN,
     +        TKOPTH(81),CMOPTH(81),CMTPTH(81),JUNK
 
      INTEGER OPEN,CREATE,GETARG,YPARSE,ZYINCI
 
      SAVE
        DATA (CIPTH(I),I=1,10)/35,
     +117,100,99,109,105,116,109,112,129/
 
      CALL ZINIT
      CALL INISTR
      CALL INISYM
      CALL INITRE
      NERROR = 0
      NWARN = 0
 
      IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
      IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
      IF (GETARG(3,TKOPTH,81).EQ.-100) CALL NAMES(3,TKOPTH)
      IF (GETARG(4,CMOPTH,81).EQ.-100) CALL NAMES(4,CMOPTH)
      IF (GETARG(5,DEPTH,3).EQ.-100)        CALL NAMES(5,DEPTH)
 
      IODTKN=OPEN(TKNPTH,0)
      IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token file.')
      IODCMT=OPEN(CMTPTH,0)
      IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment file.')
      IODTKO=CREATE(TKOPTH,1)
      IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream.')
      IODCMO=CREATE(CMOPTH,1)
      IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment stream.')
 
      IODCMI=CREATE(CIPTH,2)
      IF (IODCMO.EQ.-1) CALL ERROR('Can''t create scratch file.')
 
      IF(YPARSE(IODTKN,IODCMT,-1,IODCMI,NERROR,NWARN).NE.0) THEN
        CALL ERROR('[ISTUD - PARSER FATAL ERROR].')
      ENDIF
 
      IF(NERROR .GT. 0) THEN
        CALL ERROR('[ISTUD - PARSER ERRORS REPORTED].')
      ENDIF
 
      CALL SEEK(0, IODCMI)
      CALL SEEK(0, IODCMT)
      IF(ZYINCI(IODCMI) .EQ. -1) CALL ERROR('[ISTUD - ZYINCI ERROR].')
 
      CALL PROFIL
 
      CALL ZMESS('[ISTUD Normal Termination].',2)
      CALL ZQUIT(-2)
 
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE NAMES (NUMBER,PATH)
 
      INTEGER NUMBER,PATH(81)
 
      INTEGER ZGTCMD
      EXTERNAL ZGTCMD,ZPRMPT
 
      INTEGER JUNK,PROMPT(24,5)
 
      SAVE PROMPT
 
C "Input token stream: "
C "Input comment stream: "
C "Output token stream: "
C "Output comment stream: "
C "Input unrolling depth: "
 
      DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
     +111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +     (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
     +111,109,109,101,110,116,32,115,116,114,101,97,109,
     +58,32,129/,
     +     (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
     +116,111,107,101,110,32,115,116,114,101,97,109,
     +58,32,129/,
     +     (PROMPT(I,4),I=1,24)/79,117,116,112,117,116,32,
     +99,111,109,109,101,110,116,32,115,116,114,101,97,
     +109,58,32,129/
     +     (PROMPT(I,5),I=1,24)/73,110,112,117,116,32,
     +117,110,114,111,108,108,105,110,103,32,100,101,
     +112,116,104,58,32,129/
 
      CALL ZPRMPT(PROMPT(1,NUMBER))
      JUNK=ZGTCMD(PATH,0)
 
      END
C ----------------------------------------------------------------------
C
C       P R O F I L   -   Process files
C
 
      SUBROUTINE PROFIL
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      COMMON /CLAB/ CURLBL,CURPUN, FIRST
      LOGICAL FIRST
      INTEGER CURLBL,CURPUN
      INTEGER TEXT(134), SYMVAL(8)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
      INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZTKPTI,ZYGPUS
      EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZTOKWR,ZTKPTI,ZYGPUS,
     +         GETSTR,PROPU,ZCHOUT,ZPTMES
 
      SAVE
 
      INTEGER PTR
 
      TKNCHN = ZTKPTI(1, IODTKO, IODCMO)
      IF(TKNCHN .EQ. -1) CALL ERROR('[ISTUD - Output Stream Failure].')
 
      PTR=ZYDOWN(ZYROOT())
      CURPUN = 0
 
  100 IF (PTR.GT.0) THEN
        CURLBL = 69999
        CURPUN = CURPUN + 1
        FIRST = .TRUE.
        CALL ZYGTSY(ZYGPUS(CURPUN), SYMVAL)
        CALL ZYGTST(SYMVAL(2), TEXT)
        CALL ZCHOUT('UD Processing: ', 2)
        CALL ZPTMES(TEXT, 2)
        CALL PROPU(PTR)
        PTR=ZYNEXT(PTR)
        GO TO 100
      END IF
      CALL ZTOKWR(TZEOF,0,TEXT,TKNCHN)
 
      END
C-----------------------   GETIL.MAC
      SUBROUTINE GETIL(DOVAR, LABEL)
C Generate a variable and a label for use by ISTCD.  Each call
C results in DOVAR being set (as an IST string) to the next member of the
C sequence Mxxxxx, Myyyyy, (where yyyyy is xxxxx decremented by 1) ...
C and LABEL being set (as an IST string) to the corresponding string
C without the leading 'M'.  The first value of xxxxx is CURLBL in COMMON
C block CLAB.
 
      INTEGER DOVAR(7),LABEL(6),RESULT(8), ZYFSYM
 
      COMMON /CLAB/ CURLBL,CURPUN
      INTEGER CURLBL,CURPUN
      LOGICAL FIRST
      EXTERNAL ZITOCP, ZYFSYM, SCOPY
 
      SAVE
 
   10 CONTINUE
      CALL ZITOCP(CURLBL,LABEL,5,48)
      DOVAR(1) = 77
      CALL SCOPY(LABEL,1,DOVAR,2)
      DOVAR(7) = 129
 
      IF(ZYFSYM(DOVAR, CURPUN, RESULT) .NE. -1 .OR.
     +   ZYFSYM(LABEL, CURPUN, RESULT) .NE. -1) THEN
        CURLBL = CURLBL - 1
        GO TO 10
      ENDIF
 
      CURLBL = CURLBL - 1
 
      END
C-----------------------   TITLE.MAC
      SUBROUTINE TITLE(LABEL, STRING)
 
      CHARACTER*(*) STRING
      LOGICAL FIRST
      INTEGER LABEL(*)
      COMMON /CLAB/ CURLBL,CURPUN, FIRST
      INTEGER CURLBL,CURPUN
 
      SAVE
 
      IF(FIRST) THEN
        CALL ZMESS(' - DO loops n'//'ot unrolled as follows:.',2)
        FIRST = .FALSE.
      ENDIF
 
      CALL ZCHOUT('   .', 2)
      IF(LABEL(1) .NE. 129) THEN
        CALL ZCHOUT(STRING, 2)
        CALL ZCHOUT(' (.', 2)
        CALL PUTLIN(LABEL, 2)
        CALL ZMESS(').', 2)
      ELSE
        CALL ZMESS(STRING, 2)
      ENDIF
 
      END
C--------   NDEQM1.MAC
      INTEGER FUNCTION NDEQM1(NODE)
C Return 'yes' or 'no' according to whether the subtree rooted
C at NODE represents the constant -1 when all outer parentheses
C are removed.
C
C  MODIFIED TO HANDLE NODE=0 CASE
C
      INTEGER NODE
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER POINTR,CONONE(2),TEXT(10)
 
      INTEGER NODETP, ZYDOWN, ZYNEXT,EQUAL
      EXTERNAL NODETP,ZYDOWN,ZYNEXT,EQUAL,GETSTR
 
      DATA CONONE/49,129/
 
      NDEQM1 = -3
      IF(NODE .EQ. 0) RETURN
 
      POINTR = NODE
 
C Remove outer parentheses
   10 CONTINUE
      IF (NODETP(POINTR) .EQ. 101) THEN
         POINTR = ZYDOWN(POINTR)
         GO TO 10
      END IF
 
      IF (NODETP(POINTR) .NE. 46) RETURN
 
      POINTR = ZYDOWN(POINTR)
      IF (NODETP(POINTR) .NE. 107) RETURN
 
      CALL GETSTR(POINTR,TEXT)
      IF (EQUAL(TEXT,CONONE) .NE. -2) RETURN
 
      NDEQM1 = -2
 
      END
C--------   PROPU.MAC
C ----------------------------------------------------------------------
C
C       P R O P U   -   Process Program-Unit
C
 
      SUBROUTINE PROPU(PUROOT)
      INTEGER PUROOT
 
      INTEGER SPTR,SNUM,DOVAR(132),TYPE,
     +        ICON(4),WIDTH,J,SYMVAL(8),
     +        LBLNOD,TEXT(6),LABTRM(6),FIRST,VARNOD,E2NOD,
     +        DUMMY(2),NUM1(2),POINT,IDEP,NEWLBL(6),LAST,E1NOD,
     +        ITER(7),DOLBL(6),POINTR,E3NOD,E2DASH(7),JUNK(6),
     +        COM1(40),LABLN(6),NRDIGS,INCNOD,SAVCOM,IOD,JJ
 
      LOGICAL UNROLL,ISLBLD,FOUND
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      COMMON/UNR/ DEPTH
      INTEGER DEPTH(3)
 
      COMMON/LABLST/OLDLBS,NEWLBS,NRLBS
      INTEGER OLDLBS(6,200),NEWLBS(6,200),NRLBS
 
      INTEGER ZYDOWN,ZYNEXT,LENGTH,NAMEP,NODETP,
     +        EQUAL,CTOI,ZYPREV,URCOND,ITOC,NDEQM1
      EXTERNAL ZYDOWN,ZYNEXT,LENGTH,YSTMT,ZTOKWR,
     +         NAMEP,PUTLIN,ZCHOUT,ZPTINT,PUTCH,NODETP,UASGU,
     +         ZYGTSY,ZYGTST,CTOI,ZYPREV,URCOND,GETIL,
     +         SCOPY,COMOUT,YEXPR,SETLAB,ERROR,UDO,DOTRM,GETLAB,
     +         UIF,IFLAB,ITOC,NDEQM1
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
      SAVE
 
      DATA DUMMY(1)/129/, NUM1/49,129/, SNUM/1/, UNROLL/.FALSE./
 
C "C *** DO-loop unrolled to depth ..."
      DATA (COM1(JJ),JJ=1,31)/67,42,42,42,32,
     +        68,79,45,108,111,111,
     +        112,32,117,110,114,111,108,108,101,100,
     +        32,116,111,32,100,101,112,116,104,32/
C Fill in depth.
 
      DO 25 JJ = 1,3
         IF (DEPTH(JJ) .EQ. 129) GO TO 30
         COM1(JJ+31) = DEPTH(JJ)
   25 CONTINUE
 
   30 CONTINUE
      COM1(JJ+31) = 32
      COM1(JJ+32) = 42
      COM1(JJ+33) = 42
      COM1(JJ+34) = 42
      COM1(JJ+35) = 129
 
C Convert unrolling depth to integer.
      POINT = 1
      IDEP = CTOI(DEPTH,POINT)
 
      SPTR=ZYDOWN(PUROOT)
 
  100 TYPE = NODETP(SPTR)
 
C If a DO is encountered and unrolling is not underway, determine its
C characteristics, test whether it meets the conditions for unrolling,
C and, if it does, set up unrolling.
      IF(TYPE .EQ. 61 .AND. .NOT. UNROLL) THEN
 
C If the DO statement has a label, LBLNOD is the label node, otherwise,
C LBLNOD is the label reference node.
         LBLNOD = ZYDOWN(SPTR)
         IF (NODETP(LBLNOD) .EQ. 115) THEN
 
C Get the label.
            DOLBL(1) = 129
              CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
              CALL ZYGTST(SYMVAL(2),DOLBL)
            LBLNOD = ZYNEXT(LBLNOD)
            ISLBLD = .TRUE.
         ELSE
            ISLBLD = .FALSE.
         END IF
C LBLNOD is now the label reference for the DO.
 
C Get label reference.  This marks the end of the loop.
C Because the DO loop is assumed to be regular, this label
C is on a CONTINUE.
         LABTRM(1) = 129
           CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
           CALL ZYGTST(SYMVAL(2),LABTRM)
C Get DO variable.
         DOVAR(1) = 129
         VARNOD = ZYDOWN(ZYNEXT(LBLNOD))
           CALL ZYGTSY(-ZYDOWN(VARNOD),SYMVAL)
           CALL ZYGTST(SYMVAL(2),DOVAR)
 
C Test whether the DO satisfies the conditions for unrolling.
         IF (URCOND(SPTR,ISLBLD,DOVAR,LABTRM) .EQ. -3) GO TO 700
         UNROLL = .TRUE.
 
C Output a comment that loop is to be unrolled.
           CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
           CALL ZCHOUT('Unrolling loop labelled .',2)
           CALL PUTLIN(LABTRM, 2)
           CALL ZCHOUT(' to depth: .',2)
           CALL ZPTMES(DEPTH, 2)
 
C Assemble information for the preamble and the modified DO.
 
C Lower limit E1.
         E1NOD = ZYNEXT(VARNOD)
 
C Upper limit E2.
         E2NOD = ZYNEXT(E1NOD)
 
C Incrementation parameter E3.  If E3NOD = 0 then the incrementation
C parameter is default (1).
         E3NOD = ZYNEXT(E2NOD)
         IF (E3NOD .NE. 0) CALL REMARK('DO Loop With Incrementation'
     +     //' Parameter Not Default: Check Regularity Condition 3.')
 
C Write the iteration count statement: Mxxxxx = (E2-E1+E3)/(d*E3)
C If the original DO is labelled, write the label on the iteration
C count statement.
         IF (ISLBLD)
     +        CALL ZTOKWR(TDCNST,LENGTH(DOLBL),DOLBL,TKNCHN)
C Mxxxxx generated by GETIL
         CALL GETIL(ITER,NEWLBL)
           CALL ZTOKWR(TNAME,LENGTH(ITER),ITER,TKNCHN)
C =
           CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C E2
         CALL YEXPR(E2NOD,TKNCHN)
C -
           CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C (E1)
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
         CALL YEXPR(E1NOD,TKNCHN)
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C (E3) or 1
         IF (E3NOD .NE. 0) THEN
              CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
            CALL YEXPR(E3NOD,TKNCHN)
              CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
         ELSE
            CALL ZTOKWR(TDCNST,LENGTH(NUM1),NUM1,TKNCHN)
         END IF
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C /
           CALL ZTOKWR(TSLASH,0,DUMMY(1),TKNCHN)
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C unrolling depth
           CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
C *(E3) - omit if E3 is default (1).
         IF (E3NOD .NE. 0) THEN
              CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
              CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
            CALL YEXPR(E3NOD,TKNCHN)
              CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
         END IF
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C end-of-statement (iteration count statement)
           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the statement to calculate E2'=Myyyyy=E1+d*(E3)*(Mxxxxx-1)
C Myyyyy generated by GETIL
         CALL GETIL(E2DASH,JUNK)
           CALL ZTOKWR(TNAME,LENGTH(E2DASH),E2DASH,TKNCHN)
C =
           CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C E1
         CALL YEXPR(E1NOD,TKNCHN)
C +
           CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C unrolling depth
           CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
C *(E3) - omit if E3 = default (1)
         IF (E3NOD .NE. 0) THEN
              CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
              CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
            CALL YEXPR(E3NOD,TKNCHN)
              CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
         END IF
C *
           CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
C (
           CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
C iteration count
           CALL ZTOKWR(TNAME,LENGTH(ITER),ITER,TKNCHN)
C -
           CALL ZTOKWR(TMINUS,0,DUMMY(1),TKNCHN)
C 1
         CALL ZTOKWR(TDCNST,LENGTH(NUM1),NUM1,TKNCHN)
C )
           CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
C end-of-statement (statement to calculate E2'=Myyyyy)
           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Write the modified DO statement.
C DO
           CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C label reference
           CALL ZTOKWR(TDCNST,LENGTH(LABTRM),LABTRM,TKNCHN)
C DO variable
           CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
C =
           CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C E1
         CALL YEXPR(E1NOD,TKNCHN)
C ,
           CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E2' = Myyyyy
           CALL ZTOKWR(TNAME,LENGTH(E2DASH),E2DASH,TKNCHN)
C ,
           CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C unrolling depth
           CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
C *(E3) - omit if E3 = default (1)
         IF (E3NOD .NE. 0) THEN
              CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
              CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
            CALL YEXPR(E3NOD,TKNCHN)
              CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
         END IF
C end-of-statement (modified DO)
           CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
 
C Save statement number in preparation
C for repeating comments in the clean-up loop.
         SAVCOM = SNUM
 
C FIRST is the first statement to be replicated in unrolling.
           SPTR = ZYNEXT(SPTR)
         FIRST = SPTR
         J = 0
      END IF
C End of set up for unrolling.
  700 CONTINUE
 
 
      IF(UNROLL) THEN
C We are outputing statements in the body of the loop.
         WIDTH = 4
C Check whether we have reached the end of the range and, if so, set up
C for another unrolling pass or, if finished with unrolling, write the
C clean-up loop.
         LBLNOD = ZYDOWN(SPTR)
           IF(NODETP(LBLNOD) .EQ. 115) THEN
             CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
             CALL ZYGTST(SYMVAL(2),TEXT)
 
C Since all labels must be on CONTINUEs, the possibility of a labelled
C statement that is not a DO terminator is covered in the special
C treatment of CONTINUEs; at this point, we simply go on when such a
C statement is encountered.
             IF (EQUAL(TEXT,LABTRM) .EQ. -3) THEN
               CONTINUE
             ELSE IF(EQUAL(TEXT,LABTRM) .EQ. -2
     +                .AND. J .LT. (IDEP - 1)) THEN
C The range will be repeated with the DO variable increased by E3.
               LAST = ZYPREV(SPTR)
C Set up and/or reset the correspondence between old and new labels.
               CALL SETLAB(FIRST,LAST,J)
               J = J + 1
               SPTR = FIRST
             ELSE
C We've arrived at the CONTINUE with the label LABTRM and unrolling is
C complete.  Output the CONTINUE, save LAST for the clean-up loop and
C turn off unrolling.
 
               CALL YSTMT(SPTR,TKNCHN)
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
               LAST = ZYPREV(SPTR)
               UNROLL = .FALSE.
 
C Write the clean up loop.
C Write the DO statement.
C DO
                  CALL ZTOKWR(TDO,0,DUMMY(1),TKNCHN)
C label reference (label generated earlier by GETIL)
                 CALL ZTOKWR(TDCNST,LENGTH(NEWLBL),NEWLBL,TKNCHN)
C DO variable
                  CALL ZTOKWR(TNAME,LENGTH(DOVAR),DOVAR,TKNCHN)
C =
                  CALL ZTOKWR(TEQUAL,0,DUMMY(1),TKNCHN)
C E2' = Myyyyy
                 CALL ZTOKWR(TNAME,LENGTH(E2DASH),E2DASH,TKNCHN)
C +
                  CALL ZTOKWR(TPLUS,0,DUMMY(1),TKNCHN)
C unrolling depth
                 CALL ZTOKWR(TDCNST,LENGTH(DEPTH),DEPTH,TKNCHN)
C *(E3) - omit if E3 = default (1).
               IF (E3NOD .NE. 0) THEN
                    CALL ZTOKWR(TSTAR,0,DUMMY(1),TKNCHN)
                    CALL ZTOKWR(TLPARN,0,DUMMY(1),TKNCHN)
                  CALL YEXPR(E3NOD,TKNCHN)
                    CALL ZTOKWR(TRPARN,0,DUMMY(1),TKNCHN)
               END IF
C ,
                  CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
C E2
               CALL YEXPR(E2NOD,TKNCHN)
C ,E3 - omit if E3 = default (1).
               IF (E3NOD .NE. 0) THEN
                     CALL ZTOKWR(TCOMMA,0,DUMMY(1),TKNCHN)
                  CALL YEXPR(E3NOD,TKNCHN)
               END IF
C end-of-statement (DO for clean-up loop)
                  CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
 
C Output any block of comments that followed original DO.
               CALL COMOUT(SAVCOM)
 
C Set up and/or reset the correspondence between old and new labels.
               CALL SETLAB(FIRST,LAST,J)
C Output statements in the clean-up loop.
             POINTR = FIRST
400             TYPE = NODETP(POINTR)
               IF (TYPE .EQ. 62) THEN
                  LBLNOD = ZYDOWN(POINTR)
                  IF (NODETP(LBLNOD) .EQ. 115) THEN
C Get the replacement label.
                     CALL GETLAB(LBLNOD,LABLN,FOUND)
                     IF (.NOT. FOUND) CALL ERROR('ISTUD: Label'
     +                  //'  On CONTINUE Not Found.')
C Write CONTINUE with new label.
                         CALL ZTOKWR(TDCNST,LENGTH(LABLN),
     +                             LABLN,TKNCHN)
                        CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
                        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
                  ELSE
C Unlabelled CONTINUE. Output it.
                        CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
                        CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
                  END IF
               ELSE IF (TYPE .EQ. 51) THEN
C Get the replacement label reference if there is one.
C (Recall that all labels must be on CONTINUE statements.  Hence,
C the GO TO is not labelled.)
                  CALL GETLAB(ZYDOWN(POINTR),LABLN,FOUND)
                  IF (.NOT. FOUND) THEN
C Label not found and hence is a transfer out of the DO loop.
C Output statement as it stands.
                     CALL YSTMT(POINTR,TKNCHN)
                  ELSE
C Write GO TO with new label reference.
                       CALL ZTOKWR(TGOTO,0,DUMMY(1),TKNCHN)
                         CALL ZTOKWR(TDCNST,LENGTH(LABLN),LABLN,
     +                             TKNCHN)
C end-of-statement (GO TO statement)
                       CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
                  END IF
               ELSE IF (TYPE .EQ. 61) THEN
C Get replacement for termination label. We require that each DO range
C end on its own CONTINUE.
                  CALL GETLAB(ZYDOWN(POINTR),LABLN,FOUND)
C Write DO with new label reference.
                  IF (.NOT. FOUND) CALL ERROR('ISTUD: Label'
     +                         //' Reference for DO Not Found.')
                  CALL DOTRM(POINTR,LABLN,TKNCHN)
               ELSE IF (TYPE .EQ. 57 .OR. TYPE .EQ. 55
     +            .OR. TYPE .EQ. 58 .OR. TYPE .EQ. 56) THEN
                  CALL IFLAB(POINTR,TKNCHN)
               ELSE
                    CALL YSTMT(POINTR,TKNCHN)
               END IF
               SAVCOM = SAVCOM + 1
               CALL COMOUT(SAVCOM)
              IF (POINTR .NE. LAST) THEN
                POINTR = ZYNEXT(POINTR)
                GO TO 400
              ELSE
C Output CONTINUE for end of clean up loop.
C label
                CALL ZTOKWR(TDCNST,LENGTH(NEWLBL),NEWLBL,TKNCHN)
C CONTINUE
                CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
                     CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
               END IF
C End clean up loop.
               GO TO 600
             END IF
         END IF
C
C
C We've finished the processing associated with the discovery
C of the labelled statement (CONTINUE) that is the end of the range
C of the DO being unrolled.  The following processing is for unlabelled
C statements in the range and CONTINUEs with labels (we postponed labelled
C CONTINUEs till here.
            TYPE = NODETP(SPTR)
C If J > 0, modify the labels on CONTINUEs.
         IF (TYPE .EQ. 62 .AND. J .GT. 0) THEN
            LBLNOD = ZYDOWN(SPTR)
            IF (NODETP(LBLNOD) .EQ. 115) THEN
               CALL GETLAB(LBLNOD,LABLN,FOUND)
               IF (.NOT. FOUND) CALL ERROR('ISTUD: Label Not Found'
     +                         //' On Labelled CONTINUE.')
C Write CONTINUE with new label.
                   CALL ZTOKWR(TDCNST,LENGTH(LABLN),LABLN,
     +                       TKNCHN)
                 CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
                 CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
            ELSE
C Unlabelled CONTINUE.  Ouput it.
                  CALL ZTOKWR(TCONTI,0,DUMMY(1),TKNCHN)
C end-of-statement (CONTINUE statement)
                  CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
            END IF
C If J > 0, modify the label references in GO TOs as appropriate.
         ELSE IF (TYPE .EQ. 51 .AND. J .GT. 0) THEN
C We require that all labels be on CONTINUES; hence GO TO
C is not labelled.
            CALL GETLAB(ZYDOWN(SPTR),LABLN,FOUND)
            IF (.NOT. FOUND) THEN
C Label not found and hence is a transfer out of the DO loop.
C Output statement as it stands.
               CALL YSTMT(SPTR,TKNCHN)
            ELSE
C Write GO TO with new label reference.
                 CALL ZTOKWR(TGOTO,0,DUMMY(1),TKNCHN)
                   CALL ZTOKWR(TDCNST,LENGTH(LABLN),LABLN,
     +                       TKNCHN)
C end-of-statement (GO TO statement)
                 CALL ZTOKWR(TZEOS,0,DUMMY(1),TKNCHN)
            END IF
C If J > 0, modify assignment statements that contain the DO variable.
            ELSE IF (TYPE .EQ. 49 .AND. J .GT. 0) THEN
            IF (NAMEP(SPTR,DOVAR) .EQ. -2) THEN
C Assignment statement contains the DO variable.
C Replace DOVAR with J*E3.
               NRDIGS = ITOC(J,ICON,WIDTH)
               IF (NDEQM1(E3NOD) .EQ. -2) THEN
                  INCNOD = -1
               ELSE
                  INCNOD = E3NOD
               END IF
                 CALL UASGU(SPTR,DOVAR,ICON,INCNOD,TKNCHN)
            ELSE
C Output as it stands.
                 CALL YSTMT(SPTR,TKNCHN)
            END IF
C All labels in unrolling range are on CONTINUEs; hence inner DO
C is not labelled.
         ELSE IF (TYPE .EQ. 61 .AND. J .GT. 0) THEN
            CALL GETLAB(ZYDOWN(SPTR),LABLN,FOUND)
            IF (.NOT. FOUND) CALL ERROR('ISTUD: Cannot Find'
     +           //' Replacement Label Reference On Inner DO.')
            IF (NAMEP(ZYNEXT(ZYDOWN(SPTR)),DOVAR) .EQ. -2) THEN
C Nested DO specification contains the DO variable for the unrolling DO.
C Replace DOVAR with J*E3.
               NRDIGS = ITOC(J,ICON,WIDTH)
               IF (NDEQM1(E3NOD) .EQ. -2) THEN
                  INCNOD = -1
               ELSE
                  INCNOD = E3NOD
               END IF
                 CALL UDO(SPTR,DOVAR,ICON,INCNOD,LABLN,TKNCHN)
            ELSE
C DO specification independent of DOVAR but we still have to fix the label.
                 CALL DOTRM(SPTR,LABLN,TKNCHN)
            END IF
C If J > 0, modify IF statements.
         ELSE IF ((TYPE .EQ. 57 .OR. TYPE .EQ. 55
     +            .OR. TYPE .EQ. 58 .OR. TYPE .EQ. 56)
     +            .AND. (J .GT. 0)) THEN
            IF (NAMEP(SPTR,DOVAR) .EQ. -2) THEN
C IF contains the DO variable.
               NRDIGS = ITOC(J,ICON,WIDTH)
               IF (NDEQM1(E3NOD) .EQ. -2) THEN
                  INCNOD = -1
               ELSE
                  INCNOD = E3NOD
               END IF
               CALL UIF(SPTR,DOVAR,ICON,INCNOD,TKNCHN)
            ELSE
C IF does not contain the DO variable but we must fix the labels.
               CALL IFLAB(SPTR,TKNCHN)
            END IF
         ELSE
C We are unrolling and either J = 0 and/or type is not GO TO, CONTINUE, DO,
C IF, or assignment.
              CALL YSTMT(SPTR,TKNCHN)
            IF (J .EQ. 0) THEN
               SNUM = SNUM + 1
               CALL COMOUT(SNUM)
            END IF
         END IF
      ELSE
C We are not unrolling.
           CALL YSTMT(SPTR,TKNCHN)
         SNUM = SNUM + 1
         CALL COMOUT(SNUM)
      END IF
600     CONTINUE
        SPTR=ZYNEXT(SPTR)
        IF (SPTR.NE.0) GO TO 100
 
        END
C--------   SETLAB.MAC
C ----------------------------------------------------------------------------
C       S E T L A B - Set label correspondence
C
      SUBROUTINE SETLAB(NODF,NODL,LEVEL)
 
      INTEGER NODF,NODL,LEVEL
 
C If LEVEL=0, fill OLDLBS with the labels for the statements
C whose parse tree nodes are NODF to NODL inclusive and write
C replacements for the labels in the corresponding cells in NEWLBS.
C If LEVEL .ne. 0, replace the replacements in NEWLBS with a new set.
C NRLBS is the number of labels (max. 200).
C SETLAB is called by PROPU to supply new labels for a DO loop that
C is being unrolled.
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      COMMON/LABLST/OLDLBS,NEWLBS,NRLBS
      INTEGER OLDLBS(6,200),NEWLBS(6,200),NRLBS
 
      INTEGER SPTR,LBLNOD,SYMVAL(8),I,JUNK(7)
 
      INTEGER ZYDOWN,ZYNEXT,NODETP
      EXTERNAL ZYDOWN,ZYNEXT,NODETP,ZYGTSY,ZYGTST,GETIL
 
C Set up OLDLBS if LEVEL = 0.
      IF (LEVEL .EQ. 0) THEN
         NRLBS = 0
         SPTR = NODF
  100    LBLNOD = ZYDOWN(SPTR)
           IF (NODETP(LBLNOD) .EQ. 115) THEN
             NRLBS = NRLBS + 1
             OLDLBS(1,NRLBS) = 129
             CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
             CALL ZYGTST(SYMVAL(2),OLDLBS(1,NRLBS))
           END IF
         IF (SPTR .NE. NODL) THEN
           SPTR = ZYNEXT(SPTR)
           GO TO 100
         END IF
      END IF
 
C Fill NEWLBS with a set of label replacements.
      DO 200 I = 1,NRLBS
         CALL GETIL(JUNK,NEWLBS(1,I))
200   CONTINUE
 
      END
C--------   URCOND.MAC
C ----------------------------------------------------------------------
C
C       U R C O N D  -   Determine whether the DO loop meets the conditions
C                   for unrolling.
C
 
        INTEGER FUNCTION URCOND(DONODE,ISLBLD,IND,LBL)
 
C DONODE is the parse tree node of the DO statement, IND the index, and
C LBL the terminating label.  ISLBLD is .TRUE. or .FALSE. according to
C whether the DO statement itself is labelled or not.  All are input
C arguments.
 
C  URCOND returns 'no' if any of the following conditions
C  are encountered in the DO statement at DONODE or its associated
C  range.
C
C  (1) the loop is trivial (range has only one statement),
C
C  (2) the range contains a labelled statement that is not a
C  CONTINUE,
C
C  (3) the range contains a non-assignment statement, other than a DO,
C  or IF in which the DO variable occurs,
C
C  (4) the DO does not terminate on a CONTINUE,
C
C  (5) The DO is in the range of a DO rejected for unrolling.
C
C  (6) There is a transfer to the terminating label with a GO TO.
C
C  (7) An inner DO does not use the same terminating label as the
C  DO being checked.
C
C  Otherwise, 'yes' is returned.
 
      INTEGER DONODE,IND(*),LBL(*)
      LOGICAL ISLBLD
 
      INTEGER SYMVAL(8), LBLNOD,TEXT(132),SPTR,
     +        DOSPEC,INRLST(200),INNR,I,TYPE
 
 
      COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
      INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
 
      INTEGER ZYDOWN,ZYNEXT,NAMEP,NODETP,EQUAL
      EXTERNAL ZYDOWN,ZYNEXT,NAMEP,NODETP,ZYGTSY,ZYGTST,ZMESS,
     +         SCOPY
 
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.1
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
      SAVE
      DATA INNR /0/
 
C Is the DO is on the list of DOs inner to a rejected DO?
      DO 300 I = 1,INNR
         IF (DONODE .EQ. INRLST(I)) THEN
            TEXT(1) = 129
            CALL TITLE(TEXT,'Inner DO in the range of a rejected DO.')
            URCOND = -3
C No need to proceed further through the range.
            RETURN
         END IF
  300 CONTINUE
 
      IF (ISLBLD) THEN
         DOSPEC = ZYNEXT(ZYNEXT(ZYDOWN(DONODE)))
      ELSE
         DOSPEC = ZYNEXT(ZYDOWN(DONODE))
      END IF
 
C Does the DO loop have only one statement in its range?
      SPTR = ZYNEXT(DONODE)
      TEXT(1) = 129
      LBLNOD = ZYDOWN(SPTR)
        IF (NODETP(LBLNOD) .EQ. 115) THEN
          CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
          CALL ZYGTST(SYMVAL(2),TEXT)
          IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
            CALL TITLE(TEXT, 'Only one statement in range of DO.')
            URCOND = -3
            RETURN
          END IF
      END IF
 
  100 CONTINUE
      TYPE = NODETP(SPTR)
 
C When a DO is encountered in the range, put its node on the list
C INRLST.  This list will be used to detect inner DOs that are to be
C rejected with the outer DO is rejected.  Also check that the inner
C DO does not use the same terminating label as the DO being examined.
 
      IF(TYPE .EQ. 61) THEN
         INNR = INNR + 1
         INRLST(INNR) = SPTR
 
         LBLNOD = ZYDOWN(SPTR)
         IF (NODETP(LBLNOD) .EQ. 115) LBLNOD = ZYNEXT(LBLNOD)
         CALL GETSTR(LBLNOD,TEXT)
         IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
            CALL TITLE(TEXT, 'Inner DO uses same terminating label'
     +                    //' as outer DO.')
            URCOND = -3
            GO TO 200
         END IF
      END IF
 
C Does the DO variable occur in a statement that is not a DO, IF
C or assignment?
      IF (TYPE .NE. 49 .AND. TYPE .NE. 61 .AND.
     +      TYPE .NE. 57 .AND. TYPE .NE. 55 .AND.
     +      TYPE .NE. 58 .AND. TYPE .NE. 56 .AND.
     +      NAMEP(SPTR,IND) .EQ. -2) THEN
         TEXT(1) = 129
         CALL TITLE(TEXT, 'Index occurs in statement that is neither'
     +                //' an assignment, DO, nor IF.')
         URCOND = -3
         GO TO 200
      END IF
 
C Does the range contain a transfer to the terminating label?
      IF (TYPE .EQ. 51) THEN
         LBLNOD = ZYDOWN(SPTR)
           IF (NODETP(LBLNOD) .EQ. 115) LBLNOD = ZYNEXT(LBLNOD)
           CALL GETSTR(LBLNOD,TEXT)
           IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
             CALL TITLE(TEXT, 'Range contains transfer to terminating'
     +                    //' statement.')
             URCOND = -3
             GO TO 200
           END IF
      END IF
 
      IF (TYPE .EQ. 56) THEN
         LBLNOD = ZYDOWN(SPTR)
           IF (NODETP(LBLNOD) .EQ. 115) LBLNOD = ZYNEXT(LBLNOD)
           LBLNOD = ZYNEXT(LBLNOD)
C LBLNOD is now the node of the statement executed when IF true.
           IF (NODETP(LBLNOD) .EQ. 51) THEN
             LBLNOD = ZYDOWN(LBLNOD)
             CALL GETSTR(LBLNOD,TEXT)
             IF (EQUAL(TEXT,LBL) .EQ. -2) THEN
               CALL TITLE(TEXT, 'Range contains transfer to terminating'
     +                    //' statement.')
               URCOND = -3
               GO TO 200
             END IF
        END IF
      END IF
 
C Does the range contain a labelled statement that is
C not a CONTINUE?
      LBLNOD = ZYDOWN(SPTR)
        IF (NODETP(LBLNOD) .EQ. 115) THEN
C Get the label and check if it is the termination label.
          CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
          CALL ZYGTST(SYMVAL(2),TEXT)
          IF (EQUAL(TEXT,LBL) .EQ. -3) THEN
            IF (NODETP(SPTR) .NE. 62) THEN
               CALL TITLE(TEXT, 'Range contains labelled statement that'
     +                    //' is n'//'ot a CONTINUE.')
               URCOND = -3
               GO TO 200
            END IF
C We have arrived at the termination of the DO being checked.
C Is the termination statement a CONTINUE?
          ELSE IF (NODETP(SPTR) .NE. 62) THEN
            CALL TITLE(TEXT, 'DO termination statement'
     +                 //' is n'//'ot a CONTINUE.')
            URCOND = -3
C No need to complete list of inner DOs since we are at termination.
            RETURN
          ELSE
C The DO passes the conditions for unrolling.  Discard the list of
C nodes in INRLST.
            URCOND = -2
            INNR = 0
            RETURN
          END IF
      END IF
 
C Go on to next statement in range of DO
      SPTR = ZYNEXT(SPTR)
      GO TO 100
 
C The DO at DONODE has been rejected for unrolling.  Continue through
C the range, placing the nodes of inner DOs on INRLST.
200      CONTINUE
      SPTR = ZYNEXT(SPTR)
      LBLNOD = ZYDOWN(SPTR)
        IF (NODETP(LBLNOD) .EQ. 115) THEN
          CALL ZYGTSY(-ZYDOWN(LBLNOD),SYMVAL)
          CALL ZYGTST(SYMVAL(2),TEXT)
          IF (EQUAL(TEXT,LBL) .EQ. -2) RETURN
        END IF
      IF (NODETP(SPTR) .EQ. 61) THEN
            INNR = INNR + 1
            INRLST(INNR) = SPTR
      END IF
      GO TO 200
 
      END
